home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / env.scm < prev    next >
Text File  |  1995-10-13  |  3KB  |  98 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4.  
  5. ; Accessing packages
  6.  
  7. (define (environment-ref package name)
  8.   (carefully (package-lookup package name) contents package name))
  9.  
  10. (define (environment-set! package name value)
  11.   (let ((binding (package-lookup package name)))
  12.     (if (and (binding? binding)
  13.          (not (variable-type? (binding-type binding))))
  14.     (error "invalid assignment" name package value)
  15.     (carefully binding
  16.            (lambda (loc)
  17.              (set-contents! loc value))
  18.            package name))))
  19.  
  20. (define (environment-define! package name value)
  21.   (set-contents! (package-define! package name usual-variable-type) value))
  22.  
  23. (define (*structure-ref struct name)
  24.   (let ((binding (structure-lookup struct name #f)))
  25.     (if binding
  26.     (carefully binding contents struct name)
  27.     (error "structure-ref: name not exported" struct name))))
  28.  
  29. (define (carefully binding action env name)
  30.   (if (binding? binding)
  31.       (if (eq? (binding-type binding) syntax-type)
  32.       (error "attempt to reference syntax as variable" name env)
  33.       (let ((loc (binding-place binding)))
  34.         (if (location? loc)
  35.         (if (location-defined? loc)
  36.             (action loc)
  37.             (error "unbound variable" name env))
  38.         (error "variable has no location" name env))))
  39.       (if (unbound? binding)
  40.       (error "unbound variable" name env)
  41.       (error "peculiar binding" binding name env))))
  42.  
  43.  
  44.  
  45. ; Interaction environment
  46.  
  47. (define $interaction-environment (make-fluid #f))
  48.  
  49. (define (interaction-environment)
  50.   (fluid $interaction-environment))
  51.  
  52. (define (set-interaction-environment! p)
  53.   (if (package? p)
  54.       (set-fluid! $interaction-environment p)
  55.       (call-error "invalid package" set-interaction-environment! p)))
  56.  
  57. (define (with-interaction-environment p thunk)
  58.   (if (package? p)
  59.       (let-fluid $interaction-environment p thunk)
  60.       (call-error "invalid package" with-interaction-environment p)))
  61.  
  62.  
  63. ; Scheme report environment.  Should be read-only; fix later.
  64.  
  65. (define (scheme-report-environment n)
  66.   (if (= n *scheme-report-number*)
  67.       *scheme-report-environment*
  68.       (error "no such Scheme report environment")))
  69.  
  70. (define *scheme-report-environment* #f)
  71. (define *scheme-report-number* 0)
  72.  
  73. (define (set-scheme-report-environment! repnum env)
  74.   (set! *scheme-report-number* repnum)
  75.   (set! *scheme-report-environment* env))
  76.  
  77.  
  78.  
  79. ; Make an infinite tower of packages for syntax.
  80. ; structs should be a non-null list of structures that should be
  81. ; opened at EVERY level of the tower.
  82.  
  83. (define (make-reflective-tower eval structs id)
  84.   (let recur ((level 1))
  85.     (delay (cons eval
  86.          (make-simple-package structs
  87.                       eval
  88.                       (recur (+ level 1))
  89.                       `(for-syntax ,level ,id))))))
  90.  
  91. ; (set-reflective-tower-maker! p (lambda (clauses id) ...))
  92. ; where clauses is a list of DEFINE-STRUCTURE clauses
  93.  
  94. (define set-reflective-tower-maker!
  95.   (let ((name (string->symbol ".make-reflective-tower.")))
  96.     (lambda (p proc)
  97.       (environment-define! p name proc))))
  98.